home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / ENTRY.SWG / 0002_General Input with Color.pas < prev    next >
Pascal/Delphi Source File  |  1993-06-08  |  2KB  |  93 lines
  1. { General STRING input routine with Color prompt and input }
  2.  
  3. USES DOS,Crt;
  4.  
  5. TYPE
  6.     CharSet = Set OF Char;
  7.  
  8. VAR
  9.     Name : STRING;
  10.  
  11. procedure QWrite( Column, Line , Color : byte; S : STRING );
  12.  
  13. var
  14.    VMode  : BYTE ABSOLUTE $0040 : $0049; { Video mode: Mono=7, Color=0-3 }
  15.    NumCol : WORD ABSOLUTE $0040 : $004A; { Number of CRT columns (1-based) }
  16.    VSeg   : WORD;
  17.    OfsPos : integer;  { offset position of the character in video RAM }
  18.    vPos   : integer;
  19.    sLen   : Byte ABSOLUTE S;
  20.  
  21. Begin
  22.   If VMode in [0,2,7] THEN VSeg := $B000 ELSE VSeg := $B800;
  23.   OfsPos   := (((pred(Line) * NumCol) + pred(Column)) * 2);
  24.   FOR vPos := 0 to pred(sLen) do
  25.       MemW[VSeg : (OfsPos + (vPos * 2))] :=
  26.                      (Color shl 8) + byte(S[succ(vPos)])
  27. End;
  28.  
  29. Function GetString(cx,cy,cc,pc : Byte; Default,Prompt : String; MaxLen : Integer;OKSet :
  30. charset):string;
  31.  
  32. { cx = Input Column }
  33. { cy = Input Row    }
  34. { cc = Input Color  }
  35. { pc = Prompt Color }
  36.  
  37. const
  38.   BS                 = ^H;
  39.   CR                 = ^M;
  40.   iPutChar           = #249;
  41.   ConSet             : CharSet = [BS,CR];
  42. var
  43.   TStr               : string;
  44.   TLen,X,i           : Integer;
  45.   Ch                 : Char;
  46. begin
  47.   {$I-} { turn off I/O checking }
  48.   TStr := '';
  49.   TLen := 0;
  50.   Qwrite(cx,cy,pc,Prompt);
  51.   X := cx + Length(Prompt);
  52.   For i := x to (x + Maxlen - 1) do
  53.     Qwrite(i,cy,cc,iputChar);
  54.   Qwrite(x,cy,cc,Default);
  55.   OKSet := OKSet + ConSet;
  56.   repeat
  57.     Gotoxy(x,cy);
  58.     repeat
  59.       ch := readkey
  60.     until Ch in OKSet;
  61.     if Ch = BS then begin
  62.       if TLen > 0 then begin
  63.         TLen := TLen - 1;
  64.         X := X - 1;
  65.         QWrite(x,cy,cc,iPutChar);
  66.       end
  67.     end
  68.     else if (Ch <> CR) and (TLen < MaxLen) then begin
  69.       QWrite(x,cy,cc,Ch);
  70.       TLen := TLen + 1;
  71.       TStr[TLen] := Ch;
  72.       X := X + 1;
  73.     end
  74.   until Ch = CR;
  75.   If Tlen > 0
  76.     Then Begin
  77.            TStr[0] := chr(Tlen);
  78.            Getstring := TStr
  79.          End
  80.     Else Getstring := Default;
  81.   {$I+}
  82. end;
  83.  
  84.  
  85. BEGIN
  86.    ClrScr;
  87.    Name := Getstring(16,5,79,31,'GOOD OLE BOY','Enter Name : ',25,['a'..'z','A'..'Z',' ']);
  88.    GOTOXY(16,7);
  89.    WriteLn('Name : ',Name);
  90.    Readkey;
  91. END.
  92.  
  93.